home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / FORTH / FORTHMAC / OLD / TOOLS1 / !Forthmacs.lib.dsort < prev    next >
Text File  |  1996-05-27  |  3KB  |  89 lines
  1. \ hs 07.11.95
  2. \ Generates an array containing a sorted list of the addresses of all the
  3. \ words in the dictionary.
  4.  
  5. \ sort-dictionary ( -- )    generates the list
  6. \ word-array      ( -- adr )    address of the array of word addresses
  7. \ #words          ( -- n )    the number of words in the list
  8. \ word-index      ( adr -- i )    finds the index within the word address
  9. \                array of the largest address which is less
  10. \                than adr
  11.  
  12. needs heap-sort lib/sort.fth
  13.  
  14. only forth also hidden also  forth definitions
  15.  
  16. 0 constant word-array
  17. hidden definitions
  18. 0 constant next-location
  19.  
  20. forth definitions
  21. : #words    ( -- n )
  22.     next-location word-array -  /cell /  1-  ;
  23.  
  24. hidden definitions
  25. : new-node    ( acf -- )
  26.     next-location !
  27.     next-location  cell+  is next-location ;
  28. : count-words    ( -- #words )
  29.     \ Count the total number of words in the dictionary.
  30.     0 voc-link link@
  31.     begin
  32.         dup voc> >threads  follow
  33.         begin    another?
  34.         while    drop  ( cnt voc-link )  swap 1+ swap
  35.         repeat
  36.         link@ dup origin =
  37.     until   ( #words link )  drop ;
  38. : allocate-array  ( -- )
  39.     \ One extra slot for heap sort temporary entry, one slot for origin
  40.     count-words  2+ cells    ( #bytes )
  41.     alloc-mem  ( adr )
  42.     dup is word-array  is next-location
  43.     0  new-node
  44.     origin new-node ;
  45.  
  46. \ These 2 routines account for half of the total time for the sort,
  47. \ and they are very simple, so we should implement them in code.
  48. : dsort-test    ( i j -- flag )
  49.     word-array swap cells+ @  word-array rot cells+ @  < ;
  50. : dsort-copy    ( i j -- )
  51.     word-array rot cells+ @  word-array rot cells+ ! ;
  52. : adr@        ( index -- )
  53.     word-array swap 1+ cells+ @  ;
  54.  
  55. forth definitions
  56. \ Generates an array containing the addresses of all the words in the
  57. \ dictionary, sorted in ascending order of the word's address.
  58. : sort-dictionary    ( -- )
  59.     [""] _!@#end_ "create    \ Dummy word to mark the top of the dictionary
  60.     allocate-array
  61.         ['] dsort-test  is rec-test
  62.         ['] dsort-copy  is rec-copy
  63.     voc-link link@
  64.     begin
  65.         dup voc> >threads  follow
  66.         begin  another?  while  name> new-node  repeat
  67.         link@ dup origin =
  68.     until   drop
  69.     #words  heap-sort ;
  70.  
  71.  
  72. \ Finds the index within the word table of the last word whose address
  73. \ is <= the indicated adr.
  74. : word-index    ( adr -- n )
  75.     \ Binary search
  76.     #words 0            ( adr high low )
  77.     begin    2dup 1+ >
  78.     while                ( adr high' low' )
  79.         2dup - 2/ over +    ( adr high low test )
  80.         dup adr@        ( adr high low test test-adr )
  81.         4 pick >
  82.         if            ( adr high low test )
  83.             rot drop swap    ( adr test low )
  84.         else            ( adr high low test )
  85.             nip        ( adr high test )
  86.         then            ( adr high' low' )
  87.     repeat                ( adr high' low' )
  88.     nip nip ;            ( low )
  89.